home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / parse-body.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  1.8 KB  |  47 lines
  1. #+gcl
  2. (eval-when (compile load)
  3.        (defun parse-body (body &optional docstring-allowed env)
  4.   (do ((bodyr body (cdr bodyr))
  5.        (declarations nil)
  6.        (docstring nil)
  7.        (form nil))
  8.       ((null bodyr) (values bodyr declarations docstring))
  9.     (cond ((and (stringp (car bodyr)) (cdr bodyr) (null docstring) docstring-allowed)
  10.        (setq docstring (car bodyr))
  11.             )
  12.       ((not (listp (setq form (macroexpand (car bodyr) env))))
  13.        (return (values bodyr declarations docstring))
  14.        )
  15.       ((eq (car form) 'DECLARE)
  16.        (dolist (decl (cdr form)) (push decl declarations))
  17.        )
  18.       (t (return (values bodyr declarations docstring)))
  19.       ) ) )
  20. ;; gcl (as of today, Jan 14, 2002) lacks destructuring-bind.
  21. ;; The following version of destructuring-bind was stolen from
  22. ;; clisp 2.27.
  23. #+gcl
  24. (defmacro destructuring-bind (lambdalist form &body body &environment env)
  25.   (multiple-value-bind (body-rest declarations) (parse-body body nil env)
  26.     (if declarations (setq declarations `((DECLARE ,@declarations))))
  27.     (let ((%arg-count 0) (%min-args 0) (%restp nil)
  28.           (%let-list nil) (%keyword-tests nil) (%default-form nil))
  29.       (analyze1 lambdalist '<DESTRUCTURING-FORM> 'destructuring-bind '<DESTRUCTURING-FORM>)
  30.       (let ((lengthtest (make-length-test '<DESTRUCTURING-FORM> 0))
  31.             (mainform `(LET* ,(nreverse %let-list)
  32.                          ,@declarations
  33.                          ,@(nreverse %keyword-tests)
  34.                          ,@body-rest
  35.            ))          )
  36.         (if lengthtest
  37.           (setq mainform
  38.             `(IF ,lengthtest
  39.                (DESTRUCTURING-ERROR <DESTRUCTURING-FORM>
  40.                                     '(,%min-args . ,(if %restp nil %arg-count))
  41.                )
  42.                ,mainform
  43.         ) )  )
  44.         `(LET ((<DESTRUCTURING-FORM> ,form)) ,mainform)
  45. ) ) ) )
  46.  
  47. )